home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1995 February: Tool Chest / Dev.CD Feb 95 / Dev.CD Feb 95.toast / Tool Chest / Development Tools & Languages / Dylan Related / Mindy-1.1 (sources only) / mindy-1.1 / interp / list.c < prev    next >
Encoding:
C/C++ Source or Header  |  1994-06-28  |  6.4 KB  |  302 lines  |  [TEXT/ttxt]
  1. /**********************************************************************\
  2. *
  3. *  Copyright (c) 1994  Carnegie Mellon University
  4. *  All rights reserved.
  5. *  
  6. *  Use and copying of this software and preparation of derivative
  7. *  works based on this software are permitted, including commercial
  8. *  use, provided that the following conditions are observed:
  9. *  
  10. *  1. This copyright notice must be retained in full on any copies
  11. *     and on appropriate parts of any derivative works.
  12. *  2. Documentation (paper or online) accompanying any system that
  13. *     incorporates this software, or any part of it, must acknowledge
  14. *     the contribution of the Gwydion Project at Carnegie Mellon
  15. *     University.
  16. *  
  17. *  This software is made available "as is".  Neither the authors nor
  18. *  Carnegie Mellon University make any warranty about the software,
  19. *  its performance, or its conformity to any specification.
  20. *  
  21. *  Bug reports, questions, comments, and suggestions should be sent by
  22. *  E-mail to the Internet address "gwydion-bugs@cs.cmu.edu".
  23. *
  24. ***********************************************************************
  25. *
  26. * $Header: list.c,v 1.6 94/06/27 16:32:10 wlott Exp $
  27. *
  28. * This file implements lists.
  29. *
  30. \**********************************************************************/
  31.  
  32. #include <stdio.h>
  33. #include <stdarg.h>
  34.  
  35. #include "mindy.h"
  36. #include "gc.h"
  37. #include "coll.h"
  38. #include "class.h"
  39. #include "obj.h"
  40. #include "bool.h"
  41. #include "num.h"
  42. #include "thread.h"
  43. #include "func.h"
  44. #include "error.h"
  45. #include "print.h"
  46. #include "type.h"
  47. #include "def.h"
  48. #include "list.h"
  49.  
  50. obj_t obj_Nil = 0;
  51. obj_t obj_ListClass = 0, obj_PairClass = 0, obj_EmptyListClass = 0;
  52.  
  53. obj_t pair(obj_t head, obj_t tail)
  54. {
  55.     obj_t res = alloc(obj_PairClass, sizeof(struct list));
  56.  
  57.     HEAD(res) = head;
  58.     TAIL(res) = tail;
  59.  
  60.     return res;
  61. }
  62.  
  63. obj_t list1(obj_t x)
  64. {
  65.     return pair(x, obj_Nil);
  66. }
  67.  
  68. obj_t list2(obj_t x, obj_t y)
  69. {
  70.     return pair(x, list1(y));
  71. }
  72.  
  73. obj_t list3(obj_t x, obj_t y, obj_t z)
  74. {
  75.     return pair(x, list2(y, z));
  76. }
  77.  
  78. obj_t listn(int n, ...)
  79. {
  80.     va_list ap;
  81.     obj_t res, *tail = &res;
  82.     int i;
  83.  
  84.     va_start(ap, n);
  85.     for (i = 0; i < n; i ++) {
  86.     obj_t new = list1(va_arg(ap, obj_t));
  87.     *tail = new;
  88.     tail = &TAIL(new);
  89.     }
  90.     va_end(ap);
  91.  
  92.     *tail = obj_Nil;
  93.  
  94.     return res;
  95. }
  96.  
  97.  
  98. boolean memq(obj_t o, obj_t list)
  99. {
  100.     while (list != obj_Nil) {
  101.     if (o == HEAD(list))
  102.         return TRUE;
  103.     list = TAIL(list);
  104.     }
  105.     return FALSE;
  106. }
  107.  
  108. obj_t nreverse(obj_t list)
  109. {
  110.     obj_t result = obj_Nil;
  111.  
  112.     while (list != obj_Nil) {
  113.     obj_t t = TAIL(list);
  114.     TAIL(list) = result;
  115.     result = list;
  116.     list = t;
  117.     }
  118.     return result;
  119. }
  120.  
  121. int length(obj_t list)
  122. {
  123.     int count;
  124.  
  125.     for (count = 0; list != obj_Nil; list = TAIL(list))
  126.     count++;
  127.  
  128.     return count;
  129. }
  130.  
  131.  
  132. /* Dylan routines. */
  133.  
  134. static obj_t dylan_head(obj_t list)
  135. {
  136.     return HEAD(list);
  137. }
  138.  
  139. static obj_t dylan_head_setter(obj_t head, obj_t list)
  140. {
  141.     HEAD(list) = head;
  142.     return head;
  143. }
  144.  
  145. static obj_t dylan_tail(obj_t list)
  146. {
  147.     return TAIL(list);
  148. }
  149.  
  150. static obj_t dylan_tail_setter(obj_t tail, obj_t list)
  151. {
  152.     TAIL(list) = tail;
  153.     return tail;
  154. }
  155.  
  156. static void dylan_list(struct thread *thread, int nargs)
  157. {
  158.     obj_t *ptr = thread->sp;
  159.     obj_t result = obj_Nil;
  160.  
  161.     while (nargs-- > 0)
  162.     result = pair(*--ptr, result);
  163.  
  164.     thread->sp = ptr;
  165.     *--ptr = result;
  166.  
  167.     do_return(thread, ptr, ptr);
  168. }
  169.  
  170. static obj_t dylan_list_size(obj_t list)
  171. {
  172.     obj_t slow, fast;
  173.     int length;
  174.  
  175.     if (list == obj_Nil)
  176.     return make_fixnum(0);
  177.     if (object_class(list) != obj_PairClass)
  178.     type_error(list, obj_ListClass);
  179.  
  180.     slow = list;
  181.     fast = list;
  182.     length = 0;
  183.  
  184.     do {
  185.     fast = TAIL(fast);
  186.     if (fast == obj_Nil)
  187.         return make_fixnum(length+1);
  188.     if (object_class(fast) != obj_PairClass)
  189.         type_error(fast, obj_ListClass);
  190.     fast = TAIL(fast);
  191.     length += 2;
  192.     if (fast == obj_Nil)
  193.         return make_fixnum(length);
  194.     if (object_class(fast) != obj_PairClass)
  195.         type_error(fast, obj_ListClass);
  196.     slow = TAIL(slow);
  197.     } while (slow != fast);
  198.     return obj_False;
  199. }
  200.  
  201.  
  202. /* Printer support. */
  203.  
  204. static void print_list(obj_t list)
  205. {
  206.     int len = 0;
  207.  
  208.     printf("#(");
  209.     if (list != obj_Nil) {
  210.     while (1) {
  211.         prin1(HEAD(list));
  212.         list = TAIL(list);
  213.         if (list == obj_Nil)
  214.         break;
  215.         if (++len > 20) {
  216.         printf(" ...");
  217.         break;
  218.         }
  219.         if (!instancep(list, obj_ListClass)) {
  220.         printf(" . ");
  221.         prin1(list);
  222.         break;
  223.         }
  224.         printf(", ");
  225.     }
  226.     }
  227.     putchar(')');
  228. }
  229.  
  230.  
  231. /* GC support routines. */
  232.  
  233. static int scav_list(struct object *o)
  234. {
  235.     struct list *list = (struct list *)o;
  236.  
  237.     scavenge(&list->head);
  238.     scavenge(&list->tail);
  239.  
  240.     return sizeof(struct list);
  241. }
  242.  
  243. static obj_t trans_list(obj_t list)
  244. {
  245.     return transport(list, sizeof(struct list));
  246. }
  247.  
  248. void scavenge_list_roots(void)
  249. {
  250.     scavenge(&obj_Nil);
  251.     scavenge(&obj_ListClass);
  252.     scavenge(&obj_PairClass);
  253.     scavenge(&obj_EmptyListClass);
  254. }
  255.  
  256.  
  257. /* Init stuff. */
  258.  
  259. void make_list_classes(void)
  260. {
  261.     obj_ListClass = make_abstract_class(TRUE);
  262.     obj_PairClass = make_builtin_class(scav_list, trans_list);
  263.     obj_EmptyListClass = make_builtin_class(scav_list, trans_list);
  264. }
  265.  
  266. void init_nil(void)
  267. {
  268.     obj_Nil = alloc(obj_EmptyListClass, sizeof(struct list));
  269.     HEAD(obj_Nil) = obj_Nil;
  270.     TAIL(obj_Nil) = obj_Nil;
  271. }
  272.  
  273. void init_list_classes(void)
  274. {
  275.     init_builtin_class(obj_ListClass, "<list>", obj_MutSeqClass, NULL);
  276.     def_printer(obj_ListClass, print_list);
  277.     init_builtin_class(obj_PairClass, "<pair>", obj_ListClass, NULL);
  278.     init_builtin_class(obj_EmptyListClass, "<empty-list>",
  279.                obj_ListClass, NULL);
  280. }
  281.  
  282. void init_list_functions(void)
  283. {
  284.     define_function("pair", list2(obj_ObjectClass, obj_ObjectClass),
  285.             FALSE, obj_False, FALSE, obj_PairClass, pair);
  286.     define_function("head", list1(obj_ListClass),
  287.             FALSE, obj_False, FALSE, obj_ObjectClass, dylan_head);
  288.     define_function("head-setter", list2(obj_ObjectClass, obj_ListClass),
  289.             FALSE, obj_False, FALSE, obj_ObjectClass,
  290.             dylan_head_setter);
  291.     define_function("tail", list1(obj_ListClass),
  292.             FALSE, obj_False, FALSE, obj_ObjectClass, dylan_tail);
  293.     define_function("tail-setter", list2(obj_ObjectClass, obj_ListClass),
  294.             FALSE, obj_False, FALSE, obj_ObjectClass,
  295.             dylan_tail_setter);
  296.     define_constant("list",
  297.             make_raw_function("list", 0, TRUE, obj_False, FALSE,
  298.                       obj_Nil, obj_ObjectClass, dylan_list));
  299.     define_method("size", list1(obj_ListClass), FALSE, obj_False, FALSE,
  300.           obj_IntegerClass, dylan_list_size);
  301. }
  302.